home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / xerox-patches.lsp < prev   
Lisp/Scheme  |  1992-07-09  |  10KB  |  249 lines
  1. ;;; -*- Mode: Lisp; Package: XCL-USER; Base: 10.; Syntax: Common-Lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;;
  28.  
  29. (in-package "XCL-USER")
  30.  
  31.  
  32. ;;; Patch a bug with Lambda-substitution
  33.  
  34. #+Xerox-Lyric
  35. (defun compiler::meta-call-lambda-substitute (node)
  36.   (let* ((fn (compiler::call-fn node))
  37.      (var-list (compiler::lambda-required fn))
  38.      (spec-effects
  39.       (il:for var il:in var-list
  40.           il:unless (eq (compiler::variable-scope var) :lexical)
  41.           il:collect (compiler::effects-representation var)))
  42.      ;; Bind *SUBST-OCCURED* just so that META-SUBST-VAR-REF ahs a binding
  43.      ;; to set even when nobody cares.
  44.      (compiler::*subst-occurred* nil))
  45.     (il:for var il:in var-list
  46.       il:as tail il:on (compiler::call-args node)
  47.       il:when
  48.     (and (eq (compiler::variable-scope var) :lexical)
  49.          (compiler::substitutable-p (car tail) var)
  50.          (dolist (compiler::spec-effect spec-effects t)
  51.            (when
  52.            (not (compiler::null-effects-intersection compiler::spec-effect
  53.                                  (compiler::node-affected (car tail))))
  54.          (return nil)))
  55.          (dolist (compiler::later-arg (cdr tail) t)
  56.            (when (not (compiler::passable (car tail) compiler::later-arg))
  57.          (return nil))))
  58.     il:do
  59.       (setf (compiler::lambda-body fn)
  60.         (compiler::meta-substitute (car tail) var
  61.                        (compiler::lambda-body fn))))
  62.     (when (null (compiler::node-meta-p (compiler::lambda-body fn)))
  63.       (setf (compiler::node-meta-p fn) nil)
  64.       (setq compiler::*made-changes* t))))
  65.  
  66. ;;; Some simple optimizations missing from the compiler.
  67.  
  68.  
  69. ;; Shift by a constant.
  70.  
  71. ;; Unfortunately, these cause the compiler to generate spurious warning
  72. ;; messages about "Unknown function IL:LLSH1 called from ..."  It's not often
  73. ;; you come across a place where COMPILER-LET is really needed.
  74.  
  75. #+Xerox-Lyric
  76. (progn
  77.  
  78. (defvar *ignore-shift-by-constant-optimization* nil
  79.   "Marker used for informing the shift-by-constant optimizers that they are in
  80.  the shift function, and should not optimize.")
  81.  
  82. (defun il:lrsh1 (x)
  83.   (compiler-let ((*ignore-shift-by-constant-optimization* t))
  84.     (il:lrsh x 1)))
  85.  
  86. (defun il:lrsh8 (x)
  87.   (compiler-let ((*ignore-shift-by-constant-optimization* t))
  88.     (il:lrsh x 8)))
  89.  
  90. (defun il:llsh1 (x)
  91.   (compiler-let ((*ignore-shift-by-constant-optimization* t))
  92.     (il:llsh x 1)))
  93.  
  94. (defun il:llsh8 (x)
  95.   (compiler-let ((*ignore-shift-by-constant-optimization* t))
  96.     (il:llsh x 8)))
  97.  
  98. (defoptimizer il:lrsh il:right-shift-by-constant (x n &environment env)
  99.   (if (and (constantp n)
  100.        (not *ignore-shift-by-constant-optimization*))
  101.       (let ((shift-factor (eval n)))
  102.     (cond
  103.       ((not (numberp shift-factor))
  104.        (error "Non-numeric arg to ~S, ~S" 'il:lrsh shift-factor))
  105.       ((= shift-factor 0)
  106.        x)
  107.       ((< shift-factor 0)
  108.        `(il:llsh ,x ,(- shift-factor)))
  109.       ((< shift-factor 8)
  110.        `(il:lrsh (il:lrsh1 ,x) ,(1- shift-factor)))
  111.       (t `(il:lrsh (il:lrsh8 ,x) ,(- shift-factor 8)))))
  112.       'compiler:pass))
  113.  
  114. (defoptimizer il:llsh il:left-shift-by-constant (x n &environment env)
  115.   (if (and (constantp n)
  116.        (not *ignore-shift-by-constant-optimization*))
  117.       (let ((shift-factor (eval n)))
  118.     (cond
  119.       ((not (numberp shift-factor))
  120.        (error "Non-numeric arg to ~S, ~S" 'il:llsh shift-factor))
  121.       ((= shift-factor 0)
  122.        x)
  123.       ((< shift-factor 0)
  124.        `(il:lrsh ,x ,(- shift-factor)))
  125.       ((< shift-factor 8)
  126.        `(il:llsh (il:llsh1 ,x) ,(1- shift-factor)))
  127.       (t `(il:llsh (il:llsh8 ,x) ,(- shift-factor 8)))))
  128.       'compiler:pass))
  129.  
  130. )
  131.  
  132.  
  133. ;; Simple TYPEP optimiziation
  134.  
  135. #+Xerox-Lyric
  136. (defoptimizer typep type-t-test (object type)
  137.   "Everything is of type T"
  138.   (if (and (constantp type) (eq (eval type) t))
  139.       `(progn ,object t)
  140.       'compiler:pass))
  141.  
  142. ;;; Declare side-effects (actually, lack of side-effects) info for some
  143. ;;; internal arithmetic functions.  These are needed because the compiler runs
  144. ;;; the optimizers before checking the side-effects, so side-effect
  145. ;;; declarations on the "real" functions are oft times ignored.
  146.  
  147. #+Xerox-Lyric
  148. (progn
  149.  
  150. (il:putprops cl::%+ compiler::side-effects-data (:none . :none))
  151. (il:putprops cl::%- compiler::side-effects-data (:none . :none))
  152. (il:putprops cl::%* compiler::side-effects-data (:none . :none))
  153. (il:putprops cl::%/ compiler::side-effects-data (:none . :none))
  154. (il:putprops cl::%logior compiler::side-effects-data (:none . :none))
  155. (il:putprops cl::%logeqv compiler::side-effects-data (:none . :none))
  156. (il:putprops cl::%= compiler::side-effects-data (:none . :none))
  157. (il:putprops cl::%> compiler::side-effects-data (:none . :none))
  158. (il:putprops cl::%< compiler::side-effects-data (:none . :none))
  159. (il:putprops cl::%>= compiler::side-effects-data (:none . :none))
  160. (il:putprops cl::%<= compiler::side-effects-data (:none . :none))
  161. (il:putprops cl::%/= compiler::side-effects-data (:none . :none))
  162. (il:putprops il:lrsh1 compiler::side-effects-data (:none . :none))
  163. (il:putprops il:lrsh8 compiler::side-effects-data (:none . :none))
  164. (il:putprops il:llsh1 compiler::side-effects-data (:none . :none))
  165. (il:putprops il:llsh8 compiler::side-effects-data (:none . :none))
  166.  
  167. )
  168.  
  169. ;;; Fix a nit in the compiler
  170. #+Xerox-Lyric
  171. (progn
  172.  
  173. (il:unadvise 'compile)
  174. (il:advise 'compile ':around '(let (compiler::*input-stream*) (inner)))
  175.  
  176. )
  177.  
  178. ;;; While no person would generate code like (logor x), macro can (and do).
  179.  
  180. (defun optimize-logical-op-1-arg (form env ctxt)
  181.   (declare (ignore env ctxt))
  182.   (if (= 2 (length form))
  183.       (second form)
  184.       'compiler::pass))
  185.  
  186. (xcl:defoptimizer logior optimize-logical-op-1-arg)
  187. (xcl:defoptimizer logxor optimize-logical-op-1-arg)
  188. (xcl:defoptimizer logand optimize-logical-op-1-arg)
  189. (xcl:defoptimizer logeqv optimize-logical-op-1-arg)
  190.  
  191.  
  192. #+Xerox-Medley
  193.  
  194. ;; A bug compiling LABELS
  195.  
  196. (defun compiler::meta-call-labels (compiler::node compiler:context)
  197.   ;; This is similar to META-CALL-LAMBDA, but we have some extra information.
  198.   ;; There are only required arguments, and we have the correct number of them.
  199.   (let ((compiler::*made-changes* nil))
  200.     ;; First, substitute the functions wherever possible.
  201.     (dolist (compiler::fn-pair (compiler::labels-funs compiler::node)
  202.          (when (null (compiler::node-meta-p (compiler::labels-body compiler::node)))
  203.            (setf (compiler::node-meta-p compiler::node) nil)
  204.            (setq compiler::*made-changes* t)))
  205.       (when (compiler::substitutable-p (cdr compiler::fn-pair)
  206.                        (car compiler::fn-pair))
  207.     (let ((compiler::*subst-occurred* nil))
  208.       ;; First try substituting into the body.
  209.       (setf (compiler::labels-body compiler::node)
  210.         (compiler::meta-substitute (cdr compiler::fn-pair)
  211.                        (car compiler::fn-pair)
  212.                        (compiler::labels-body compiler::node))) 
  213.       (when (not compiler::*subst-occurred*)
  214.         ;; Wasn't in the body - try the other functions.
  215.         (dolist (compiler::target-pair (compiler::labels-funs compiler::node))
  216.           (unless (eq compiler::target-pair compiler::fn-pair)
  217.         (setf (cdr compiler::target-pair)
  218.               (compiler::meta-substitute (cdr compiler::fn-pair)
  219.                          (car co